Shareware Grab Bag/Shareware Grab Bag.iso/007/modula.arc/BENCH.MOD

Text File | 1985-05-30 | 20.8 KB | 491 lines

(* Read a text and count the number of words with length
   1, 2, ... , 20, and those with length greater than 20.
   Words are separated by blanks or ends of lines. *)

MODULE wordlengths;

FROM InOut IMPORT WriteString, WriteLn, WriteCard, OpenInput, Read, Done;


VAR i,k: CARDINAL;
    ch: CHAR;
    count: ARRAY [1..21] OF CARDINAL;

BEGIN
  OpenInput('TEXT');
  FOR i := 1 TO 21 DO count[i] := 0 END;
  LOOP
    Read(ch);
    IF NOT Done THEN EXIT END;
    IF ('A' <= CAP(ch)) AND (CAP(ch) <= 'Z') THEN
      k := 0;
      REPEAT
        INC(k); Read(ch);
      UNTIL (CAP(ch)< 'A') OR ('Z' < CAP(ch));
      IF k > 20 THEN k := 21 END;
      INC(count[k])
    END
  END;
  WriteLn;
  WriteString('  Length  Count');
  FOR i := 1 TO 21 DO
    WriteCard(i,6); WriteCard(count[i],6)
  END
END wordlengths.

    END; (* with *)
  END; (* if *)
END printTree;

PROCEDURE search(x : CARDINAL; VAR p : ref);
BEGIN
  IF p = NIL THEN (* word is not in tree; insert it *)
  NEW(p);
  WITH p^ DO
   key := x;
   count := 1;
   left := NIL;
   right := NIL;
  END; (* with *)
  ELSIF x<p^.key THEN search(x, p^.left)
  ELSIF x > p^.key THEN search(x,p^.right)
  ELSE p^.count := p^.count + 1;
  END;
END search;

PROCEDURE delete(x : CARDINAL; VAR p : ref);
VAR q : ref;
  PROCEDURE del(VAR r : ref);
  BEGIN
    IF r^.right # NIL THEN
     del(r^.right)
    ELSE
     q^.key := r^.key;
     q^.count := r^.count;
     q := r;
     r := r^.left;
    END;
  END del;

BEGIN (* delete *)
  IF p = NIL THEN
    WriteString(" word is not in tree");
    WriteLn;
  ELSIF x < p^.key THEN delete(x, p^.left)
  ELSIF x > p^.key THEN delete(x,p^.right)
  ELSE
    q := p;
    IF q^.right = NIL THEN p := q^.left
    ELSIF q^.left = NIL THEN p := q^.right
    ELSE del(q^.left);
    END;
  END;
END delete;

BEGIN (*main*)
  root := NIL;
  ReadInt(k);
  WHILE k # 0 DO
   IF k > 0 THEN
     WriteString(" insert");
     WriteInt(k,6);
     search(k,root);
   ELSE
     WriteString(" delete");
     WriteInt(0-k,6);
     delete(CARDINAL(0-k), root);
   END;
   printTree(root,0);
   ReadInt(k);
  END; (*while *)
END tree.

r1) # (long2-1) THEN Str1[long2] := eos END;
END StringIs;

PROCEDURE ShowString(Str : ARRAY OF CHAR );

(* Procedure to display a string on the console *)

VAR i,long : CARDINAL;
BEGIN
    long := Len(Str);
    FOR i := 0 TO (long-1) DO
        Write(Str[i]);
    END;
END ShowString;

PROCEDURE StringAdd (VAR Str1 : ARRAY OF CHAR; Str2 : ARRAY OF CHAR );

(* Procedure to concatenate two strings such that,                 *)
(*                     Str1 = Str1 + Str2                          *)
(*                                                                 *)
(*-----------------------------------------------------------------*)
(*  Error Handling : If Str2 will be concatenated to strign Str1   *)
(*  in as much "free space" is availble.                           *)
(*-----------------------------------------------------------------*)


VAR
    i,long1,long2, hi : CARDINAL;
BEGIN

(* Obtain the length of the strings  *)
    hi := HIGH(Str1);
    long1 := Len(Str1);
    long2 := Len(Str2);

(* If string Str2 if too long pick up only the portion that will *)
(* fit  in string Str1.                                          *)
    IF (long1+long2-1) > hi THEN long2 := hi - long1 + 1 END;
        FOR i := 0 TO (long2-1) DO
            Str1[i+long1] := Str2[i]
        END;

(* Put the eos if string Str1 is not full to capacity *)
        IF hi # (long1+long2-1) THEN Str1[long1+long2] := eos END;
END StringAdd;

PROCEDURE StringDelete(VAR Str : ARRAY OF CHAR ; First,Last : CARDINAL);

(* Procedure to delete a portion of a string by specifying the first *)
(* and last character by position.                                   *)
(*                                                                   *)
(*-------------------------------------------------------------------*)
(*  Error Handling :                                                 *)
(*                                                                   *)
(*  (1) If Fisrt is greater than the string length, string Str will  *)
(*      remain intact.                                               *)
(*  (2) If Last is graeter than the string length, string Str will   *)
(*      end at position Last.                                        *)
(*-------------------------------------------------------------------*)


VAR i,long : CARDINAL;
BEGIN
    long := Len(Str);

(* If the first character is greater than the string length ignore   *)
(* the Procedure altogether.                                         *)

    IF First < long THEN


       IF Last >= long (* Check if the last character *)
                       (* position is within limits.  *)
              THEN
        Str[First] := eos

              ELSE (* Delete up to the last character *)
                FOR i := Last TO (long-1) DO
            Str[First+i-Last-1] := Str[i]
        END;

        (* Put the eos if string Str1 *)
        Str[long+First-Last-1] := eos
       END;
    END;
END StringDelete;

PROCEDURE StringPos(Str1,Str2 : ARRAY OF CHAR ; Start : CARDINAL):CARDINAL;

(* Returns the position where the sub-string Str2 occurs within string *)
(* starting at positon 'Start' Str1.                                   *)
(*                                                                     *)
(*---------------------------------------------------------------------*)
(*  Error Handling :                                                   *)
(*  (1) If Str2 is bigger than Str1 to begin with, then there can be   *)
(*      no matching of Str2 in Str1.                                   *)
(*  (2) If Start is greater than the length of Str1 then return zero   *)
(*      as a result.                                                   *)
(*---------------------------------------------------------------------*)


VAR
    long1,long2,ptr1,ptr2,last : CARDINAL;
    Found : BOOLEAN;

BEGIN

(* Initialize and obtain string lengths *)
    IF Start = 0 THEN Start := 1 END;
    ptr1 := Start-1; ptr2 :=0; last := ptr1;
    Found := FALSE;
    long1 := Len(Str1);
    long2 := Len(Str2);
(* Peform the function if the sub-string is indeed the smaller *)
    IF (long1 >= long2) AND (Start <= (long1-1)) THEN
        REPEAT
            IF Str1[ptr1] = Str2[ptr2]
                THEN
                    IF ptr2 = 0 THEN last := ptr1 END;
                    IF ptr2 = long2-1
                          THEN
                        Found := TRUE
                          ELSE
                        INC(ptr2)
                    END;
                ELSE
                    IF ptr2 > 0 THEN ptr1 := last; ptr2 := 0 END;
            END;
            INC(ptr1)
        UNTIL (Found = TRUE) OR (ptr1 >= long1-1);
    END;
(* Return zero if there was no match.                          *)
    IF NOT Found THEN ptr1 := 0
             ELSE DEC(ptr1,long2-1)
    END;
    RETURN ptr1
END StringPos;

PROCEDURE StringLeft(VAR Str1 : ARRAY OF CHAR ;
                         Str2 : ARRAY OF CHAR; Count : CARDINAL);

(* Procedure will return the 'Count' leftmost characters of string *)
(* Str2 and save the result in string Str1.                        *)
(*                                                                 *)
(*-----------------------------------------------------------------*)
(*  Error Handling :                                               *)
(* (1) If Count = 0 then reassugn Count as 1.                      *)
(* (2) If Count is greater than the string length then adjust it   *)
(*     to equal the latter.                                        *)
(*-----------------------------------------------------------------*)

VAR long : CARDINAL;

BEGIN

    StringIs(Str1,Str2);
    long := Len(Str1) - 1;
    IF Count = 1 THEN Count := 1 END;
    IF Count > long THEN Count := long END;
    IF Count <> long THEN
          Str1[Count] := eos
    END;
END StringLeft;

PROCEDURE StringRight(VAR Str1 : ARRAY OF CHAR ;
                          Str2 : ARRAY OF CHAR;  Count : CARDINAL);

(* Procedure will return the 'Count' rightmost characters of string *)
(* Str2 and save the result in string Str1.                         *)
(*                                                                  *)
(*------------------------------------------------------------------*)
(*  Error Handling : If Count is zero or greater than the string    *)
(*  length then string Str1 will be an exact copy of Str2.          *)
(*------------------------------------------------------------------*)

VAR i,long ,used: CARDINAL;
BEGIN

(* Copy string Str2 into string Str1 and obtain its length.         *)
    StringIs(Str1,Str2);
    long := Len(Str1);
    IF (Count <= long) AND (Count # 0) THEN

(* Obtain the first character position to relocate string Str1.     *)
        used := long - Count;
        FOR i := 0 TO (Count-1) DO
            Str1[i] := Str1[used+i]
        END;
        Str1[Count] := eos
    END;
END StringRight;

PROCEDURE StringMid(VAR Str1 : ARRAY OF CHAR ;
                        Str2 : ARRAY OF CHAR;  Start, Count : CARDINAL);

(* Procedure will copy the portion of string Str2 from the character   *)
(* position 'Start' and for 'Count' characters into string Str1.       *)
(*                                                                     *)
(*---------------------------------------------------------------------*)
(*  Error Handling : If the sum of Start and Count is greater than the *)
(*  string length then the resulting string Str1 will be identical to  *)
(*  string Str2.                                                       *)
(*---------------------------------------------------------------------*)

VAR i,long : CARDINAL;
BEGIN
    StringIs(Str1,Str2);
    IF Start > 0 THEN DEC(Start) END;
    long := Len(Str1);
    IF (Start + Count) <= long THEN
        FOR i := Start TO (Start+Count-1) DO
            Str1[i-Start] := Str1[i]
        END;
        IF HIGH(Str1) # Count THEN Str1[Count] := eos END;
    END;
END StringMid;

PROCEDURE StringRemove(VAR Str1 : ARRAY OF CHAR; Str2 : ARRAY OF CHAR);

(* Procedure to remove all occurences of sub-string Str2 from Str1. *)

VAR
    i,long1,long2,ptr,position,move,high : CARDINAL;

BEGIN
    high := HIGH(Str1);
    long1 := Len(Str1);
    long2 := Len(Str2);
    ptr := 1;
    REPEAT
        position := StringPos(Str1,Str2,ptr);
        IF position # 0 THEN (* Shift characters to overwrite Str2 *)
            ptr := position - 1;
            FOR i := (ptr+long2) TO (long1-1) DO
                Str1[i-long2] := Str1[i]
            END;
            DEC(long1,long2);
            Str1[long1] := eos;
        END;
    UNTIL position = 0; (* Cannot find any more sub-strings *)
END StringRemove;

PROCEDURE StringInsert(VAR Str1 : ARRAY OF CHAR; Str2 : ARRAY OF CHAR;
                          Start : CARDINAL);

(* Procedure will insert string Str2 in Str1 at the character *)
(* position 'Start' of string Str1.                           *)
(*                                                            *)
(*------------------------------------------------------------*)
(*  Error Handling : If there no room for string Str2 to be   *)
(*  inserted entirely string Str1 will remain intact.         *)
(*------------------------------------------------------------*)

VAR
   i,long1,long2 : CARDINAL;
BEGIN
        DEC(Start);
        long1 := Len(Str1);
        long2 := Len(Str2);
        IF (long1+long2-1) <= HIGH(Str1) THEN

(* Relocate portions of Str1 to make way for string Str2.      *)
                FOR i := (long1-1) TO Start BY -1 DO
                        Str1[i+long2] := Str1[i]
                END;

(* Copy string Str2 into the reserved loaction of string Str1. *)
                FOR i := Start TO (Start+long2-1) DO
                        Str1[i] := Str2[i-Start]
                END;
                INC(long1,long2);
                IF (long1-1) < HIGH(Str1) THEN Str1[long1] := eos END;
        END;
END StringInsert;

PROCEDURE StringReplace(VAR Str1 : ARRAY OF CHAR; Str2,Str3 : ARRAY OF CHAR);

(* Procedure will replace all occurences of sub-string Str2, in string *)
(* Str1, by sub-string Str3.                                           *)

VAR
    i,long1,long2,long3,ptr,pos,Stringhigh : CARDINAL;
BEGIN
    long1 := Len(Str1);
    long2 := Len(Str2);
    long3 := Len(Str3);
    ptr := 1;
    Stringhigh := HIGH(Str1)+1;
    REPEAT
        pos := StringPos(Str1,Str2,ptr);
        IF pos # 0 THEN
            ptr := pos;
            StringDelete(Str1,ptr,(ptr+long2-1));
            StringInsert(Str1,Str3,ptr);
            long1 := long1 - long2 + long3;
            IF long1 = Stringhigh THEN pos :=0
                                  ELSE Str1[long1] := eos
            END;
        END;
    UNTIL pos = 0;
END StringReplace;

PROCEDURE StringChange(VAR Str1 : ARRAY OF CHAR; Str2,Str3 : ARRAY OF CHAR;
                           Start,Repeat:CARDINAL);

(* Procedure will replace sub-string Str2 with Str3 in string Str1 *)
(* start at character position 'Start' and for 'Repeat' times.     *)

VAR
    i,long1,long2,long3,ptr,pos,Stringhigh : CARDINAL;
BEGIN
    long1 := Len(Str1);
    long2 := Len(Str2);
    long3 := Len(Str3);
    ptr := Start;
    Stringhigh := HIGH(Str1)+1;
    REPEAT
        pos := StringPos(Str1,Str2,ptr);
        IF pos # 0 THEN
            ptr := pos;
            StringDelete(Str1,ptr,(ptr+long2-1));
            StringInsert(Str1,Str3,ptr);
            long1 := long1 - long2 + long3;
            IF long1 = Stringhigh THEN pos :=0
                                  ELSE Str1[long1] := eos
            END;
        DEC(Repeat);
        END;
    UNTIL pos*Repeat = 0;
END StringChange;

PROCEDURE StringAlter(VAR Str1 : ARRAY OF CHAR; Str2 : ARRAY OF CHAR;
                                Start : CARDINAL);

(* Procedure will overwrite string Str1 with sub-string Str2 starting *)
(* at position 'Start'.                                               *)
(*                                                                    *)
(*--------------------------------------------------------------------*)
(*  Error Handling : If there is no room for string Str2 to fit in    *)
(*  its entirey string Str1 will remain intact.                       *)
(*--------------------------------------------------------------------*)

VAR
    i,long,ptr : CARDINAL;
BEGIN
    DEC(Start);
    long := Len(Str2);
    IF (Start+long-1) <= HIGH(Str1) THEN
        FOR i := Start TO (Start+long-1) DO
            Str1[i] := Str2[i-Start]
        END;
    END;
END StringAlter;

PROCEDURE InputString (VAR Str : ARRAY OF CHAR);

(* Read string from the keyboard.                                    *)

VAR
    i,high : CARDINAL;
    ch : CHAR;
BEGIN
    high := HIGH(Str);
    i := 0;
    REPEAT
        Read(ch);
        Write(ch);
        IF ch # CHAR(177C)
                THEN
                    Str[i] := ch;
                    INC(i)
                ELSE
                    Write(' ');
                    Write(ch);
                    IF i > 0 THEN DEC(i) END;
        END;
    UNTIL (ch = CHAR(36C)) OR (i > high);
    IF i <= high THEN
           DEC(i);
           Str[i] := eos
    END;
END InputString;

END Strlib.
)e'*** Make these changes permanent (y/n)?,2 ...wait>=PDCOM1:aêV===DIALING DIRECTORY sp Modem dialing command = rÄLong distance service +# = a«-# = d╕   Names+─Phone #   Comm Param  Echo Mesg Strip Pace ,⌠##
·-e     x N   Np=!$Dial entry #:             | or...t&JEnter: R to revise or add to directorytM for manual dialingîF / B to page through directoryr░X to exit to terminal 5╩| For long distance service, precede entry # with +/-y
+▒

R
Müâ&===DIALING d6===DIAL PHONE #:J(cancelled)N!ZRevise/add entry #:       | or...e!ÇEnter:  M to change modem commande ª+ / - to change long distance #s╩C to clear directory entriesΩX to exit to dialing prompts

CName: Phone number: $,Communications parameters ok (y/n)? TBaud rate: odParity:
p# data bits: s
é# stop bits: s'öAre the remaining parameters ok (y/n)? t└Echo on (y/n)? n╘Messages on (y/n)? a ∞Strip/convert characters (y/n)? old strip/cnvt string: s,change this (y/n)? n3D(please refer to instructions in the documentation)/|new strip/cnvt string: cÿnew string ok (y/n)?░//~
║Pacing? p=╚  N  g
╥nß
╪Is entry #µ ok (y/n)? o÷Modem dialing command:Long distance +#:m&Long distance -#:m<Clear directory from entry #: ^ ... through entry #:ex-- Are you sure (y/n)? töATDT£------------------------╕- --- --- ----&╩     ===FUNCTION KEY DIRECTORY===     ⌠ F1-10■F-   Input StringK  =  Press:  R to revise 4 -F assignmentsF F / B to page through directory=j X to exit to terminal ä Press Func. key to revise:ó or X to exit to terminal╛ -F─  Alt-F╬ Shft-F╪ Ctrl-FΓ New input string for n#ⁿ  as substitute for carriage returns $!Use ,! to leave key unchangediH!<space>v
T! to clear key Df! Redialing...  *** HIT ANY KEY TO TERMINATE ***  (redial started at 
«!)
┤!===REDIALING  Ç;Ä8╬! REMOTE COMPUTER ON LINE  *** HIT ANY KEY TO PROCEED ***â"===CONNECTED WITH ,$"===REDIAL TERMINATED...back in terminal mode àX"  Elapsed time this call =      x" min      6å"*** This program requires that you have a serial port.└"(returning to DOS)Hå.┌"===PLEASE DO NOT BYPASS THE FREEWARE NOTICE===#<<#>>#Not a valid file name.2#File not found.eF#Disk is write protected.b#Check disk drive.tx#Disk media error.tWêaê1ìÇTë
₧#CHECK PRINTERr@Iï%ì1╕#*** Invalid communications parameters. Try again.p"ε#*** Invalid parameters for entry #8Bì!$*** Invalid stripping for entry ##(CìB$TIMEOUTaN$PRINTOUT OFF^$CHECK MODEMFn$OVERFLOWz$PRINTOUT OFFè$OVERFLOW--PRINTOUT OFF%è!¿$*** File(s) not found. Try again.#Çcî╥$*** DISK IS FULLµ$===DISK IS FULL===ⁿ$***CAN'T OPEN  nî%***ó%*** Either too many files, ora░`î@% Try again.tP%*** /X%*** Can't read/write file in the default drive.n#î%Correct and hit any key to resume..fHë└Uî╝% Sorry, NON-RECOVERABLE ERROR ▐% at line3"    If you have received this program from another user and4"  find it of value, your $35 contribution will be appreciated.5"6"                        ═══ Freeware ═══7"                      Post Office Box 8628"                       Tiburon, CA 949209":"   You are encouraged to copy this program as described below.;"<"  ** NOTICE:  Users of this program are granted a limited license to="     make copies of this program for trial use by others on a private>"     non-commercial basis.  This limited license does not include --?"  1. distributing this program in connection with any other product@"  2. making the program available for any consideration or 'disk fee'A"  3. posting the program for public access via telecommunications orB"  4. distributing the program in modified form.  Please cooperate.C"D"  Copyright (c) 1984 The Headlands Press, Inc.π"      =====   PC-TALK III    =====Σ"σ"       Communications Program forµ"       The IBM Personal Computerτ"Φ" Press: <Home> for command summaryΘ"        <Alt>-E if you can't seeΩ"               your keyboard inputM"PrtSc =  print screen contentsN" ^PrtSc =  contin. printout (or ^PgUp)O"  Alt-R =  Receive a file  (or PgDn)P"  Alt-T =  Transmit a file  (or PgUp)Q" transmit: pacing '=p'  binary '=b'R"tran/recv: XMODEM '=x'S"  Alt-V =  View file   Alt-Y = deleteT"  Alt-D =  Dialing directoryU"  Alt-Q =  redial last numberV"  Alt-K =  set/clear Func keys (Alt-J)W"  Alt-=    set/clear temp Alt keysX" Alt-E = Echo toggle  Alt-M = MessageY" Alt-S = Screendump   Alt-C = ClearscZ"  Alt-P =  communications Parameters["  Alt-F =  set program deFaults\"  Alt-L =  change Logged drive]"  Alt-W =  set margin Width alarm^"  Alt-Z =  elapsed time/current call_"  Alt-X =  eXit to DOS`"Ctrl-End = send sustained Break signal╗M Baud rate,300,Parity,E,Data bits,7,Stop bits,1,Echo,N,Messages,N╝M"Strip #1",0,Replace #1,0,"Strip #2",0,Replace #2,0,"Strip #3",0,Replace #3,0,Pacing p=,,Logged drive,"B:",Margin width,70╜M Screendump file,"B:SCRNDUMP.PCT",Redial delay,20,Connect prompt,CONNECT╛M Line 25 help,Y,Foreground,7,Background,0,High int